perm filename PR5[1,DBL] blob
sn#011039 filedate 1972-12-10 generic text, type T, neo UTF8
00100 BEGIN
00200 EXPR GETVARS(E);
00300 ORDER(OUTNIL(FLATTEN(E)));
00400 EXPR OUTNIL(L);
00500 BEGIN NEW M;
00600 FOR NEW I IN L DO
00700 BEGIN
00800 IF I = 'C THEN I←'CC; IF I='D THEN I←'DD;
00900 IF NOT(MEMBER(I,'(NIL PLUS MINUS TIMES EXPT))
01000 OR MEMBER(I,M) OR NUMBERP(I)) THEN M← I CONS M; RETURN M; END;
01100 RETURN M; END;
01200 EXPR NVARS(E); LENGTH(GETVARS (E));
01300 EXPR DEL1(I,AA);
01400 FOR NEW J IN CDR(AA) COLLECT <(J↑(I-1)) @ (SUFLIST (J,I))>;
01500 EXPR PMATRIX(AA);
01600 FOR NEW I IN A DO BEGIN PRINT I; END;
01700 EXPR GENARGS(NV,LP);
01800 FOR NEW D←1 TO LP COLLECT
01900 <FOR NEW V←1 TO NV COLLECT <REMAINDER ((EXPT(V,D) -
02000 V*D -V - D - 23),
02100 17)- 9>>;
02200 EXPR GENTARG(NV,DEG);
02300 FOR NEW V←1 TO NV COLLECT <V*(5-DEG*4)>;
02400 EXPR GENMATRIX(DEG,INPUT,VARS,LP);
02500 BEGIN NEW G,AA,BB,ZZ,NV;
02600 NV←LENGTH(VARS);
02700 ZZ ← ZV(NV,INPUT,VARS);
02800 G←GENARGS(NV,LP-1 );
02900 FOR NEW I←1 TO LP-1 DO BEGIN
03000 FOR NEW J←1 TO NV DO SET(VARS[J],G[I,J]);
03100 AA[I]←(POLY(DEG,NV,VARS) ↑ (LP-1));
03200 BB[I]←( EVAL(INPUT))-ZZ; END;
03300 RETURN (AA CONS BB CONS ZZ); END;
03400 EXPR GETCO(DEG,INPUT,VARS,LP);
03500 BEGIN NEW G,AA,BB;
03600 G←GENMATRIX(DEG,INPUT,VARS,LP);
03700 AA←G[1]; BB←G[2]; ZZ←CDDR(G);
03800 RETURN ( SOLVE(AA,BB) @ <ZZ>) ; END;
03900 EXPR TESTCO(C,VARS,DEG,INPUT,LP);
04000 BEGIN NEW G,NV;
04100 NV←LENGTH(VARS);
04200 G←GENTARG(NV, LP);
04300 FOR NEW I←1 TO NV DO SET(VARS[I],G[I]);
04400 IF EVAL('PLUS CONS (C * ⊗ POLY(DEG,NV,VARS)))
04500 = EVAL(INPUT) THEN RETURN T ELSE RETURN NIL; END;
04600 EXPR TRY(DEG,VARS,INPUT);
04700 BEGIN NEW C;
04800 LP← LPOLY(DEG, LENGTH(VARS));
04900 IF DEG=0 THEN C←<ZV(LENGTH(VARS),INPUT,VARS)> ELSE
05000 C← GETCO(DEG,INPUT,VARS,LP);
05100 IF TESTCO(C,VARS,DEG,INPUT,LP) OR DEG=4 THEN RETURN (C CONS DEG)
05200 ELSE RETURN TRY(DEG+1,VARS,INPUT); END;
05300 EXPR SF(E);
05400 BEGIN NEW VARS,R,C,DEG;
05500 VARS←GETVARS(E);
05600 E←ALTER(E);
05700 R← TRY(0,VARS,E);
05800 C←R[1];
05900 DEG← CDR(R);
06000 TERPRI(NIL);TERPRI(NIL);PRINTSTR '"DEGREE ";
06100 PRINT DEG; PRINTSTR '"MY STANDARD FORM IS"; PRINT C;
06200 PRINTSTR '"YOUR STANDARD FORM IS";
06300 SFPRINT(VARS,DEG,C); TERPRI(NIL); E END;
06400 EXPR FLATTEN(S);
06500 IF ATOM(S) THEN <S>
06600 ELSE FLATTEN(CAR(S)) @ FLATTEN(CDR (S));
06700 EXPR ORDER(L);
06800 BEGIN FOR NEW KOUNTR←1 TO LENGTH(L) DO
06900 FOR NEW J←1 TO LENGTH(L)-1 DO
07000 FOR NEW I←J TO LENGTH(L)-1 DO
07100 IF ORDERP(L[I+1],L[I]) THEN BEGIN NEW TEMP;
07200 TEMP←L[I]; L[I]←L[I+1]; L[I+1]←TEMP;
07300 RETURN L; END; RETURN L; END;
07400
07500 DSKIN(ORDERFILE);
07600 EE ← '(TIMES 20 (PLUS (TIMES 3 B (EXPT A 2)) (EXPT (PLUS A 3) 2)
07700 (MINUS (TIMES 2 B))) A);
07800 FF ← '(PLUS (TIMES 2 A B) (MINUS C) D);
07900 FF2 ← '(PLUS (TIMES 2 A B) (MINUS Q) U);
08000 EXPR ROUND(X);
08100 BEGIN NEW XX;
08200 XX ← FIX(X+00.500);
08300 IF XX ≥ 16 THEN
08400 XX← QUOTIENT(XX,10) * 10;
08500 RETURN XX; END;
08600 EXPR SFPRINT(VARS, DEG, C); BEGIN
08700 PJ←0;
08800 RETURN PRINT(FINDOT2(OUTN(SFP(DEG,C,VARS))));
08900 END;
09000 EXPR SFP(DEG,C,VARS);
09100 BEGIN NEW X;
09200 IF NULL(VARS) OR DEG=0 THEN
09300 PJ←PJ+1 ALSO
09400 IF C[PJ] = 0 THEN RETURN NIL
09500 ELSE RETURN C[PJ];
09600 IF LENGTH(VARS)=1 AND C[PJ+1]=0 THEN
09700 PJ←PJ+1 ALSO RETURN SFP(DEG-1, C,VARS);
09800 FOR NEW I←DEG TO 0 BY -1 DO BEGIN
09900 NEW I2; I2←DEG-I+1;
10000 IF I≥1 THEN X[DEG-I+1]←CAR(VARS) CONS I
10100 ELSE X[I2]←NIL;
10200 IF LENGTH(VARS) ≥ 2 THEN BEGIN NEW L;
10300 L←SFP(DEG-I,C,CDR(VARS));
10400 IF L AND X[I2] THEN X[I2]←X[I2] CONS L
10500 ELSE IF L THEN X[I2]←L
10600 ELSE X[I2]←NIL; END;
10700 IF LENGTH(VARS) = 1 THEN BEGIN
10800 PJ←PJ+1;
10900 IF X[I2] AND C[PJ]≠0 THEN X[I2]←X[I2] CONS C[PJ]
11000 ELSE IF C[PJ]≠0 THEN X[I2]←C[PJ];
11100 END; END;
11200 RETURN OUTN(X); END;
11300 EXPR FINDOT(E); BEGIN NEW L;
11400 L←LENGTH(E);
11500 E[L-1]←E[L-1] CONS E[L];
11600 RETURN E ↑ (L-1);
11700 END;
11800 EXPR OUTN(E);
11900 BEGIN NEW M;
12000 IF ATOM(E) THEN RETURN E;
12100 FOR NEW I IN E DO
12200 IF I AND (ATOM(I) OR NOT(ATOM(CAR(I))))
12300 THEN M← I CONS M;
12400 M← REV(M);
12500 RETURN M;
12600 END;
12700 EXPR FINDOT2(E);
12800 BEGIN NEW L;
12900 L←LENGTH(E);
13000 IF L ≤ 1 THEN RETURN E;
13100 IF SUFLIST(E,L) THEN RETURN FINDOT(E);
13200 E[L]←FINDOT2(E[L]);
13300 RETURN E;
13400 END;
13500 EXPR EXPT(AA,N);
13600 IF N=0 OR AA=1 THEN 1 ELSE IF AA=0 THEN 0
13700 ELSE IF N=1 THEN AA ELSE AA*EXPT(AA,N-1);
13800 EXPR LPOLY(DEG,NV);
13900 IF DEG=0 OR NV=0 THEN 1 ELSE
14000 FOR NEW I←0 TO DEG; PLUS LPOLY(I,NV-1);
14100 EXPR POLY(DEG,NV,VARS);
14200 EREV(POLY2(DEG,NV,VARS));
14300 EXPR POLY2(DEG,NV,VARS);
14400 IF DEG=0 OR NV=0 THEN <1> ELSE
14500 FOR NEW I←0 TO DEG COLLECT
14600 <EXPT(EVAL(CAR(VARS)), DEG-I) * ⊗
14700 POLY(I,NV-1,CDR(VARS))>;
14800 EXPR OUTNIL2(L);
14900 BEGIN NEW M;
15000 IF ATOM(L) THEN RETURN L;
15100 FOR NEW I IN L DO
15200 IF I THEN M←I CONS M; RETURN M; END;
15300 EXPR EREV(L);
15400 IF ATOM(L) THEN L ELSE
15500 FOR NEW I IN L COLLECT IF ATOM(I) THEN <I>
15600 ELSE I;
15700 EXPR REV(L);
15800 IF ATOM(L) OR NULL(CDR(L)) THEN L ELSE
15900 REV(CDR(L)) @ <CAR(L)>;
16000 EXPR ZV(NV,INPUT,VARS);
16100 BEGIN FOR NEW I←1 TO NV DO
16200 SET(VARS[I],0);
16300 RETURN EVAL(INPUT); END;
16400 EXPR COMBOS(L,N);
16500 IF LENGTH(L) ≥ N THEN
16600 IF N=0 THEN NIL ELSE
16700 IF N=1 THEN FOR NEW J IN L COLLECT <<J>> ELSE
16800 BEGIN
16900 NEW COMBINATIONS;
17000 COMBINATIONS←FOR NEW X IN COMBOS(CDR L, N-1)
17100 COLLECT <L[1] CONS X>;
17200 RETURN (COMBINATIONS @ COMBOS(CDR L, N))
17300 END;
17400 EXPR SOLVE(AA,BB);
17500 BEGIN NEW X,FAC,L,N;
17600 L ← LENGTH(AA);
17700 FOR NEW I1←1 TO L DO BEGIN
17800 BB[I1] ← FLOAT(BB[I1]);
17900 FOR NEW I2 ← 1 TO L DO
18000 AA[I1,I2]←FLOAT(AA[I1,I2]);
18100 END;
18200 FOR NEW I←1 TO L DO BEGIN
18300 FOR NEW J←1 TO L DO
18400 N←J UNTIL ABS(AA[I,J])≥ 0.000110;
18500 IF N=L AND AA[I,L]=0 THEN
18600 RETURN NIL;
18700 FAC ← AA[I,N];
18800 FOR NEW I3←1 TO L DO
18900 AA[I,I3] ← AA[I,I3] / FAC;
19000 BB[I] ← BB[I] / FAC;
19100 FOR NEW K←1 TO L DO IF K ≠ I THEN BEGIN
19200 FAC ← AA[K,N];
19300 FOR NEW M←1 TO L DO
19400 AA[K,M]←AA[K,M] - AA[I,M]*FAC;
19500 BB[K]←BB[K]-BB[I]*FAC;
19600 END; END;
19700 FOR NEW M3←1 TO L DO X[M3]←0;
19800 FOR NEW KK←1 TO L DO
19900 FOR NEW MM←1 TO L DO
20000 IF AA[KK,MM] ≠ 0 THEN X[MM]←ROUND(BB[KK]/AA[KK,MM]);
20100 RETURN X
20200 END;
20300 EXPR FLOAT(X); X+0.00;
20400 EXPR CDREPLACE(E);
20500 FOR NEW I IN E COLLECT
20600 IF I='C OR I='D THEN <I,I>
20700 ELSE <I>;
20800 END.